home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MATH.SWG / 0070_High Precision BCD Math.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  48KB  |  1,562 lines

  1. unit AJCBCD;
  2.  
  3. interface
  4.  
  5. uses Objects, Strings;
  6.  
  7. const
  8.   DigitSize = SizeOf(Byte);
  9.   bpw_Fixed = 0;
  10.   bpw_Variable = 1;
  11.   bpz_Blank = True;
  12.   bpz_NotBlank = False;
  13.   MaxBCDSize = 100;
  14.   st_Blanks25 = '                         ';
  15.   st_Blanks = st_Blanks25
  16.             + st_Blanks25
  17.             + st_Blanks25
  18.             + st_Blanks25
  19.             + st_Blanks25
  20.             + st_Blanks25
  21.             + st_Blanks25
  22.             + st_Blanks25
  23.             + st_Blanks25
  24.             + st_Blanks25
  25.             + st_Blanks25;
  26.  
  27. type
  28.   PBCDArray = ^TBCDArray;
  29.   TBCDArray = array[1..MaxBCDSize] of byte;
  30.  
  31.   TBCDSign = (BCDNegative, BCDPositive);
  32.  
  33.   PBCD = ^TBCD;
  34.   TBCD = object(TObject)
  35.     BCDSize:  Integer;
  36.     Sign:  TBCDSign;
  37.     Value:  PBCDArray;
  38.     Precision: Byte;
  39.     constructor InitBCD(AVal: PBCD);
  40.     constructor InitReal(AVal: Real; APrec: Byte; ASize: Integer);
  41.     constructor InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);
  42.     destructor Done; virtual;
  43.     constructor Load(var S: TStream);
  44.     procedure Store(var S: TStream);
  45.     function GetValue: PBCDArray;
  46.     function GetSign: TBCDSign;
  47.     function GetPrecision: Byte;
  48.     function GetBCDSize: Integer;
  49.     procedure SetValueBCD(AVal: PBCD);
  50.     procedure SetValueReal(AVal: Real);
  51.     procedure SetValuePChar(AVal: PChar);
  52.     procedure SetSign(ASign: TBCDSign);
  53.     procedure SetPrecision(APrec: Byte);
  54.     procedure SetBCDSize(ASize: Integer);
  55.     procedure AddBCD(AVal: PBCD);
  56.     procedure AddReal(AVal: Real);
  57.     procedure AddPChar(AVal: PChar);
  58.     procedure SubtractBCD(AVal: PBCD);
  59.     procedure SubtractReal(AVal: Real);
  60.     procedure SubtractPChar(AVal: PChar);
  61.     procedure MultiplyByBCD(AVal: PBCD);
  62.     procedure MultiplyByReal(AVal: Real; APrec: Byte);
  63.     procedure MultiplyByPChar(AVal: PChar; APrec: Byte);
  64.     procedure DivideByBCD(AVal: PBCD);
  65.     procedure DivideByReal(AVal: Real; APrec: Byte);
  66.     procedure DivideByPChar(AVal: PChar; APrec: Byte);
  67.     procedure AbsoluteValue;
  68.     procedure Increment;
  69.     procedure Decrement;
  70.     procedure ShiftLeft(ShiftAmount: Byte);
  71.     procedure ShiftRight(ShiftAmount: Byte);
  72.     function BCD2Int: LongInt;
  73.     function BCD2Real: Real;
  74.     function PicStr(picture: string;
  75.                     Width: Integer; BlankWhenZero: Boolean): String;
  76.     function StrPic(dest: PChar; picture: string;
  77.                     Width: Integer; BlankWhenZero: Boolean;
  78.                     Size: Integer): PChar;
  79.     function CompareBCD(AVal: PBCD): Integer;
  80.     function CompareReal(AVal: Real): Integer;
  81.     function ComparePChar(AVal: PChar): Integer;
  82.   end;
  83.  
  84. const
  85.  
  86.   RBCD:  TStreamRec = (ObjType:  60000;
  87.                        VmtLink:  Ofs(TypeOf(TBCD)^);
  88.                        Load:     @TBCD.Load;
  89.                        Store:    @TBCD.Store);
  90.  
  91. var
  92.   BCDZero:  PBCD;
  93.  
  94. implementation
  95.  
  96. {BCDAdd is a subroutine that adds the value in BCD2 to the value in   }
  97. {BCD1.  It is a simple magnitude addition, as if the two numbers have }
  98. {the same sign.  BCDAdd makes the following assumptions:              }
  99. {  1) the calling routine will manage the proper sign of the result   }
  100. {     of the addition.                                                }
  101. {  2) the BCDSize of the two operands are equal                       }
  102. {  3) the Precision of the two operands are equal                     }
  103. procedure BCDAdd(BCD1, BCD2: PBCD);
  104. var
  105.   i:  integer;
  106.   Carry:  Byte;
  107. begin
  108.   Carry := 0;
  109.   for i := BCD1^.BCDSize downto 1 do
  110.     begin
  111.       BCD1^.Value^[i] := BCD1^.Value^[i] + BCD2^.Value^[i] + Carry;
  112.       if BCD1^.Value^[i] > 9 then
  113.         begin
  114.           dec(BCD1^.Value^[i], 10);
  115.           Carry := 1;
  116.         end
  117.       else
  118.         Carry := 0;
  119.     end;
  120. end;
  121.  
  122. {BCDSubtraction is a subroutine that subtracts the value in BCD2 from  }
  123. {the value in BCD1.  It is a simple magnitude subtraction, without     }
  124. {regard to the sign of the operands.  BCDSubtract makes the following  }
  125. {assumptions:                                                          }
  126. {  1) the calling routine will manage the proper sign of the result    }
  127. {     of the subtraction.                                              }
  128. {  2) the BCDSize of the two operands are equal                        }
  129. {  3) the Precision of the two operands are equal                      }
  130. {  4) the magnitude of the value in BCD2 is less than or equal to the  }
  131. {     magnitude of the value in BCD1 so that the routine can perform   }
  132. {     a simple byte by byte subtraction                                }
  133. procedure BCDSubtract(BCD1, BCD2: PBCD);
  134. var
  135.   i:  integer;
  136.   Borrow:  Byte;
  137. begin
  138.   Borrow := 0;
  139.   for i := BCD1^.GetBCDSize downto 1 do
  140.     begin
  141.       BCD1^.Value^[i] := BCD1^.Value^[i] + 10 - BCD2^.Value^[i] - Borrow;
  142.       if BCD1^.Value^[i] >  9 then
  143.         begin
  144.           dec(BCD1^.Value^[i], 10);
  145.           Borrow := 0;
  146.         end
  147.       else
  148.         Borrow := 1;
  149.     end;
  150. end;
  151.  
  152. constructor TBCD.InitBCD(AVal: PBCD);
  153. begin
  154.   inherited Init;
  155.   BCDSize := AVal^.GetBCDSize;
  156.   GetMem(Value, BCDSize*DigitSize);
  157.   Precision := AVal^.GetPrecision;
  158.   SetValueBCD(AVal);
  159. end;
  160.  
  161. constructor TBCD.InitReal(AVal: Real; APrec: Byte; ASize: Integer);
  162. begin
  163.   inherited Init;
  164.   if ASize > MaxBCDSize then
  165.     BCDSize := MaxBCDSize
  166.   else
  167.     BCDSize := ASize;
  168.   GetMem(Value, ASize*DigitSize);
  169.   Precision := APrec;
  170.   SetValueReal(AVal);
  171. end;
  172.  
  173. constructor TBCD.InitPChar(AVal: PChar; APrec: Byte; ASize: Integer);
  174. begin
  175.   inherited Init;
  176.   if ASize > MaxBCDSize then
  177.     BCDSize := MaxBCDSize
  178.   else
  179.     BCDSize := ASize;
  180.   GetMem(Value, ASize*DigitSize);
  181.   Precision := APrec;
  182.   SetValuePChar(AVal);
  183. end;
  184.  
  185. destructor TBCD.Done;
  186. begin
  187.   FreeMem(Value, BCDSize*DigitSize);
  188.   inherited Done;
  189. end;
  190.  
  191. constructor TBCD.Load(var S: TStream);
  192. begin
  193.   S.Read(BCDSize, SizeOf(BCDSize));
  194.   S.Read(Sign, SizeOf(Sign));
  195.   GetMem(Value, BCDSize*DigitSize);
  196.   S.Read(Value^, BCDSize*DigitSize);
  197.   S.Read(Precision, SizeOf(Precision));
  198. end;
  199.  
  200. procedure TBCD.Store(var S: TStream);
  201. begin
  202.   S.Write(BCDSize, SizeOf(BCDSize));
  203.   S.Write(Sign, SizeOf(Sign));
  204.   S.Write(Value^, BCDSize*DigitSize);
  205.   S.Write(Precision, SizeOf(Precision));
  206. end;
  207.  
  208. function TBCD.GetValue: PBCDArray;
  209. var
  210.   WrkValue:  PBCDArray;
  211. begin
  212.   GetMem(WrkValue, BCDSize*DigitSize);
  213.   Move(Value^, WrkValue^, BCDSize*DigitSize);
  214.   GetValue := WrkValue;
  215. end;
  216.  
  217. function TBCD.GetSign: TBCDSign;
  218. begin
  219.   GetSign := Sign;
  220. end;
  221.  
  222. function TBCD.GetPrecision: Byte;
  223. begin
  224.   GetPrecision := Precision;
  225. end;
  226.  
  227. function TBCD.GetBCDSize:  Integer;
  228. begin
  229.   GetBCDSize := BCDSize;
  230. end;
  231.  
  232. procedure TBCD.SetValueBCD(AVal: PBCD);
  233. var
  234.   SaveSize:  Integer;
  235.   SavePrecision:  Byte;
  236. begin
  237.   if AVal = nil then exit;
  238.  
  239.   FreeMem(Value, BCDSize*DigitSize);
  240.  
  241.   SaveSize := GetBCDSize;
  242.   SavePrecision := GetPrecision;
  243.  
  244.   Value := AVal^.GetValue;
  245.   BCDSize := AVal^.GetBCDSize;
  246.   Precision := AVal^.GetPrecision;
  247.  
  248.   if Precision > SavePrecision then
  249.     begin
  250.       SetBCDSize(SaveSize);
  251.       SetPrecision(SavePrecision);
  252.     end
  253.   else
  254.     begin
  255.       SetPrecision(SavePrecision);
  256.       SetBCDSize(SaveSize);
  257.     end;
  258.  
  259.     SetSign(AVal^.GetSign);
  260. end;
  261.  
  262. procedure TBCD.SetSign(ASign: TBCDSign);
  263. var
  264.   i:  integer;
  265. begin
  266.   Sign := BCDPositive;
  267.   if ASign = BCDPositive then exit;
  268.  
  269.   {allow negative sign only if value is non-zero}
  270.   for i := GetBCDSize downto 1 do
  271.     if Value^[i] <> 0 then
  272.       begin
  273.         Sign := BCDNegative;
  274.         exit;
  275.       end;
  276. end;
  277.  
  278. procedure TBCD.SetValueReal(AVal: Real);
  279. var
  280.   i, BCDIndex:  integer;
  281.   ValStr: String;
  282. begin
  283.   FillChar(Value^, BCDSize*DigitSize, #0);
  284.  
  285.   Str(abs(AVal):BCDSize:Precision, ValStr);
  286.   BCDIndex := BCDSize;
  287.   for i :=length(ValStr) downto 1 do
  288.     if ValStr[i] in ['0'..'9'] then
  289.       begin
  290.         Value^[BCDIndex] := ord(ValStr[i]) - ord('0');
  291.         dec(BCDIndex);
  292.       end;
  293.  
  294.   if AVal < 0.0 then
  295.     SetSign(BCDNegative)
  296.   else
  297.     SetSign(BCDPositive);
  298. end;
  299.  
  300. procedure TBCD.SetValuePChar(AVal: PChar);
  301. var
  302.   i, BCDIndex:  integer;
  303.   SavePrec: Byte;
  304.   SaveSign: TBCDSign;
  305. begin
  306.   if AVal = nil then exit;
  307.  
  308.   SaveSign := BCDPositive;
  309.   SavePrec := Precision;
  310.   Precision := 0;
  311.  
  312.   FillChar(Value^, BCDSize*DigitSize, #0);
  313.  
  314.   if StrLen(AVal) = 0 then exit;
  315.  
  316.   BCDIndex := BCDSize;
  317.   for i := StrLen(AVal) downto 0 do
  318.     case AVal[i] of
  319.       '0'..'9':     begin
  320.                       Value^[BCDIndex] := ord(AVal[i]) - ord('0');
  321.                       dec(BCDIndex);
  322.                     end;
  323.       '(',')','-':  begin
  324.                       SaveSign := BCDNegative;
  325.                     end;
  326.       '.':          begin
  327.                       Precision := BCDSize - BCDIndex;
  328.                     end;
  329.     end;  {case}
  330.  
  331.   SetPrecision(SavePrec);
  332.   SetSign(SaveSign);
  333. end;
  334.  
  335. procedure TBCD.SetPrecision(APrec: Byte);
  336. begin
  337.   if APrec = Precision then exit;
  338.   if APrec < Precision then
  339.     ShiftRight(Precision - APrec)
  340.   else
  341.     ShiftLeft(APrec - Precision);
  342.   Precision := APrec;
  343. end;
  344.  
  345. procedure TBCD.SetBCDSize(ASize: Integer);
  346. var
  347.   SaveSize:  Integer;
  348.   WrkVal:  PBCDArray;
  349. begin
  350.   if ASize = GetBCDSize then exit;
  351.  
  352.   if ASize > MaxBCDSize then ASize := MaxBCDSize;
  353.  
  354.   GetMem(WrkVal, ASize*DigitSize);
  355.   FillChar(WrkVal^, ASize*DigitSize, #0);
  356.  
  357.   if ASize < GetBCDSize then
  358.     Move(Value^[(GetBCDSize-ASize)+1], WrkVal^, ASize*DigitSize)
  359.   else if ASize > GetBCDSize then
  360.     Move(Value^, WrkVal^[(ASize-GetBCDSize)+1], GetBCDSize);
  361.  
  362.   FreeMem(Value, GetBCDSize*DigitSize);
  363.   Value := WrkVal;
  364.   BCDSize := ASize;
  365. end;
  366.  
  367. procedure TBCD.AddBCD(AVal: PBCD);
  368. var
  369.   WrkValue:  PBCD;
  370. begin
  371.   WrkValue := new(PBCD, InitBCD(AVal));
  372.   WrkValue^.SetPrecision(Precision);
  373.   WrkValue^.SetBCDSize(BCDSize);
  374.   if GetSign <> AVal^.GetSign then
  375.     if AVal^.GetSign = BCDNegative then
  376.       begin
  377.         WrkValue^.AbsoluteValue;
  378.         BCDSubtract(@Self, WrkValue);
  379.         Dispose(WrkValue, Done);
  380.         exit;
  381.       end
  382.     else
  383.       {AVal^.GetSign = BCDPositive}
  384.       begin
  385.         AbsoluteValue;
  386.         BCDSubtract(WrkValue, @Self);
  387.         SetValueBCD(WrkValue);
  388.         Dispose(WrkValue, Done);
  389.         exit;
  390.       end;
  391.  
  392.   BCDAdd(@Self, WrkValue);
  393.   Dispose(WrkValue, Done);
  394. end;
  395.  
  396. procedure TBCD.AddReal(AVal: Real);
  397. var
  398.   WrkValue: PBCD;
  399. begin
  400.   WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  401.   AddBCD(WrkValue);
  402.   Dispose(WrkValue, Done);
  403. end;
  404.  
  405. procedure TBCD.AddPChar(AVal: PChar);
  406. var
  407.    WrkValue: PBCD;
  408. begin
  409.   WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  410.   AddBCD(WrkValue);
  411.   Dispose(WrkValue, Done);
  412. end;
  413.  
  414. procedure TBCD.SubtractBCD(AVal: PBCD);
  415. var
  416.   WrkValue:  PBCD;
  417.   SaveSign:  TBCDSign;
  418. begin
  419.   if AVal = nil then exit;
  420.  
  421.   WrkValue := new(PBCD, InitBCD(AVal));
  422.   WrkValue^.SetPrecision(GetPrecision);
  423.   WrkValue^.SetBCDSize(GetBCDSize);
  424.   if GetSign <> AVal^.GetSign then
  425.     begin
  426.       WrkValue^.SetSign(Sign);
  427.       BCDAdd(@Self, WrkValue);
  428.       Dispose(WrkValue, Done);
  429.       exit;
  430.     end;
  431.  
  432.   SaveSign := Sign;
  433.   AbsoluteValue;
  434.   WrkValue^.AbsoluteValue;
  435.   if CompareBCD(WrkValue) < 0 then
  436.     begin
  437.       BCDSubtract(WrkValue, @Self);
  438.       SetValueBCD(WrkValue);
  439.       if SaveSign = BCDNegative then
  440.         SetSign(BCDPositive)
  441.       else
  442.         SetSign(BCDNegative);
  443.     end
  444.   else
  445.     begin
  446.       BCDSubtract(@Self, WrkValue);
  447.       SetSign(SaveSign);
  448.     end;
  449.  
  450.   Dispose(WrkValue, Done);
  451. end;
  452.  
  453. procedure TBCD.SubtractReal(AVal: Real);
  454. var
  455.   WrkValue: PBCD;
  456. begin
  457.   WrkValue := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  458.   SubtractBCD(WrkValue);
  459.   Dispose(WrkValue, Done);
  460. end;
  461.  
  462. procedure TBCD.SubtractPChar(AVal: PChar);
  463. var
  464.   WrkValue: PBCD;
  465. begin
  466.   WrkValue := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  467.   SubtractBCD(WrkValue);
  468.   Dispose(WrkValue, Done);
  469. end;
  470.  
  471. procedure TBCD.MultiplyByBCD(AVal: PBCD);
  472. var
  473.   NewSign:  TBCDSign;
  474.   WrkValue:  PBCD;
  475.   HighDigit, i, j:  integer;
  476.   SavePrec:  Byte;
  477. begin
  478.   if AVal = nil then exit;
  479.  
  480.   if GetSign = AVal^.GetSign then
  481.     NewSign := BCDPositive
  482.   else
  483.     NewSign := BCDNegative;
  484.   AbsoluteValue;
  485.  
  486.   SavePrec := Precision;
  487.   WrkValue := new(PBCD, InitReal(0, 0, GetBCDSize + AVal^.GetBCDSize));
  488.   Precision := 0;
  489.   i := 1;
  490.   while (i < AVal^.GetBCDSize) and (AVal^.Value^[i] = 0) do
  491.     inc(i);
  492.   HighDigit := i;
  493.  
  494.   for i := AVal^.GetBCDSize downto HighDigit do
  495.     begin
  496.       if AVal^.Value^[i] <> 0 then
  497.         for j := 1 to AVal^.Value^[i] do
  498.           WrkValue^.AddBCD(@Self);
  499.       ShiftLeft(1);
  500.     end;
  501.  
  502.   WrkValue^.Precision := SavePrec + AVal^.GetPrecision;
  503.   WrkValue^.SetPrecision(SavePrec);
  504.   Precision := SavePrec;
  505.   SetValueBCD(WrkValue);
  506.   SetSign(NewSign);
  507. end;
  508.  
  509. procedure TBCD.MultiplyByReal(AVal: Real; APrec: Byte);
  510. var
  511.   WrkVal:  PBCD;
  512. begin
  513.   WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));
  514.   MultiplyByBCD(WrkVal);
  515.   Dispose(WrkVal, Done);
  516. end;
  517.  
  518. procedure TBCD.MultiplyByPChar(AVal: PChar; APrec: Byte);
  519. var
  520.   WrkVal:  PBCD;
  521. begin
  522.   WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));
  523.   MultiplyByBCD(WrkVal);
  524.   Dispose(WrkVal, Done);
  525. end;
  526.  
  527. procedure TBCD.DivideByBCD(AVal: PBCD);
  528. var
  529.   NewSign:  TBCDSign;
  530.   WrkVal, WrkDiv, WrkQuo:  PBCD;
  531.   HighDigit, i, j, IterationCount:  integer;
  532.   TempPrec, QuotientPrec:  Byte;
  533. begin
  534.   if AVal = nil then exit;
  535.  
  536.   if AVal^.CompareReal(0.0) = 0 then exit;  {avoid zero divide}
  537.  
  538.   if GetSign = AVal^.GetSign then
  539.     NewSign := BCDPositive
  540.   else
  541.     NewSign := BCDNegative;
  542.  
  543.   WrkVal := new(PBCD, InitBCD(@Self));
  544.   WrkVal^.AbsoluteValue;
  545.  
  546.   WrkQuo := new(PBCD, InitReal(0, 0, GetBCDSize));
  547.  
  548.   i := 1;
  549.   while (i < WrkVal^.GetBCDSize) and (WrkVal^.Value^[i] = 0) do
  550.     inc(i);
  551.   HighDigit := i;
  552.   WrkVal^.SetPrecision(WrkVal^.GetPrecision+(HighDigit-1));
  553.   TempPrec := WrkVal^.GetPrecision;
  554.   WrkVal^.Precision := 0;
  555.  
  556.   WrkDiv := new(PBCD, InitBCD(AVal));
  557.   WrkDiv^.AbsoluteValue;
  558.   i := 1;
  559.   while (i < WrkDiv^.GetBCDSize) and (WrkDiv^.Value^[i] = 0) do
  560.     inc(i);
  561.   HighDigit := i;
  562.   WrkDiv^.ShiftLeft(HighDigit - 1);
  563.   WrkDiv^.Precision := 0;
  564.  
  565.   QuotientPrec := TempPrec - AVal^.GetPrecision;
  566.   IterationCount := WrkVal^.GetBCDSize - QuotientPrec + GetPrecision;
  567.  
  568.   for i := 1 to IterationCount do
  569.     begin
  570.       while CompareBCD(WrkDiv) > 0 do
  571.         begin
  572.           WrkVal^.SubtractBCD(WrkDiv);
  573.           inc(WrkQuo^.Value^[WrkQuo^.GetBCDSize]);
  574.         end;
  575.       WrkDiv^.ShiftRight(1);
  576.       WrkQuo^.ShiftLeft(1);
  577.     end;
  578.  
  579.   WrkQuo^.Precision := QuotientPrec;
  580.   SetValueBCD(WrkQuo);
  581.   SetSign(NewSign);
  582.  
  583.   Dispose(WrkVal, Done);
  584.   Dispose(WrkQuo, Done);
  585.   Dispose(WrkDiv, Done);
  586. end;
  587.  
  588. procedure TBCD.DivideByReal(AVal: Real; APrec: Byte);
  589. var
  590.   WrkVal:  PBCD;
  591. begin
  592.   WrkVal := new(PBCD, InitReal(AVal, APrec, GetBCDSize));
  593.   DivideByBCD(WrkVal);
  594.   Dispose(WrkVal, Done);
  595. end;
  596.  
  597. procedure TBCD.DivideByPChar(AVal: PChar; APrec: Byte);
  598. var
  599.   WrkVal: PBCD;
  600. begin
  601.   WrkVal := new(PBCD, InitPChar(AVal, APrec, GetBCDSize));
  602.   DivideByBCD(WrkVal);
  603.   Dispose(WrkVal, Done);
  604. end;
  605.  
  606. procedure TBCD.AbsoluteValue;
  607. begin
  608.   SetSign(BCDPositive);
  609. end;
  610.  
  611. procedure TBCD.Increment;
  612. begin
  613.   AddReal(1);
  614. end;
  615.  
  616. procedure TBCD.Decrement;
  617. begin
  618.   SubtractReal(1);
  619. end;
  620.  
  621. procedure TBCD.ShiftLeft(ShiftAmount: Byte);
  622. var
  623.   i:  integer;
  624. begin
  625.   if ShiftAmount = 0 then exit;
  626.   for i := 1 to (BCDSize - ShiftAmount) do
  627.     Value^[i] := Value^[i+ShiftAmount];
  628.   for i := ((BCDSize - ShiftAmount) + 1) to BCDSize do
  629.     Value^[i] := 0;
  630. end;
  631.  
  632. procedure TBCD.ShiftRight(ShiftAmount: Byte);
  633. var
  634.   i:  integer;
  635. begin
  636.   if ShiftAmount = 0 then exit;
  637.   for i := BCDSize downto (ShiftAmount + 1) do
  638.     Value^[i] := Value^[i - ShiftAmount];
  639.   for i := ShiftAmount downto 1 do
  640.     Value^[i] := 0;
  641. end;
  642.  
  643. function TBCD.BCD2Int: LongInt;
  644. var
  645.   i:  integer;
  646.   wrkLongInt:  LongInt;
  647. begin
  648.   BCD2Int := 0;
  649.   if Precision = GetBCDSize then exit;
  650.  
  651.   wrkLongInt := 0;
  652.   i := 1;
  653.   repeat
  654.     wrkLongInt := wrkLongInt * 10;
  655.     wrkLongInt := wrkLongInt + Value^[i];
  656.     inc(i);
  657.   until i = (GetBCDSize - GetPrecision);
  658.   if GetSign = BCDNegative then
  659.     BCD2Int := -wrkLongInt
  660.   else
  661.     BCD2Int := wrkLongInt;
  662. end;
  663.  
  664. function TBCD.BCD2Real: Real;
  665. var
  666.   i:  integer;
  667.   wrkIntegerPart, wrkFractionPart:  real;
  668. begin
  669.   BCD2Real := 0.0;
  670.   wrkIntegerPart := 0;
  671.   wrkFractionPart := 0;
  672.  
  673.   if GetPrecision < GetBCDSize then
  674.     begin
  675.       i := 1;
  676.       repeat
  677.         wrkIntegerPart := wrkIntegerPart * 10.0;
  678.         wrkIntegerPart := wrkIntegerPart + Value^[i];
  679.         inc(i);
  680.       until i = (GetBCDSize - GetPrecision + 1);
  681.     end;
  682.  
  683.   if Precision > 0 then
  684.     begin
  685.       i := GetBCDSize;
  686.       repeat
  687.         wrkFractionPart := wrkFractionPart + Value^[i];
  688.         wrkFractionPart := wrkFractionPart / 10.0;
  689.         dec(i);
  690.       until i = (GetBCDSize - GetPrecision);
  691.     end;
  692.  
  693.   if GetSign = BCDNegative then
  694.     BCD2Real := -(wrkIntegerPart + wrkFractionPart)
  695.   else
  696.     BCD2Real := (wrkIntegerPart + wrkFractionPart);
  697. end;
  698.  
  699. function TBCD.PicStr(picture: string;
  700.                      Width: Integer; BlankWhenZero: Boolean): String;
  701.  
  702. var
  703.    integer_str, decimal_str, pic_str, val_str:  string;
  704.    decimal_encountered, significant_digits_encountered:  boolean;
  705.    number_of_digits, number_of_integer_digits, number_of_decimal_digits,
  706.    sub_pic, sub_val, i:  integer;
  707.  
  708. begin    {pic}
  709.   decimal_encountered := false;
  710.   number_of_digits := 0;
  711.   number_of_integer_digits := 0;
  712.   for i := 1 to length(picture) do
  713.     if upcase(picture[i]) in ['$', '-', '9', 'Z'] then
  714.       begin
  715.         inc(number_of_digits);
  716.         if not decimal_encountered then
  717.           inc(number_of_integer_digits);
  718.       end
  719.     else if picture[i] = '.' then
  720.        decimal_encountered := true;
  721.   number_of_decimal_digits := number_of_digits - number_of_integer_digits;
  722.  
  723.   integer_str := '';
  724.   for i := (GetBCDSize - GetPrecision) downto 1 do
  725.     integer_str := char(ord('0')+Value^[i]) + integer_str;
  726.   if length(integer_str) > number_of_integer_digits then
  727.     delete(integer_str, 1, length(integer_str)-number_of_integer_digits)
  728.   else
  729.     while length(integer_str) < number_of_integer_digits do
  730.       integer_str := '0' + integer_str;
  731.  
  732.   decimal_str := '';
  733.   for i := (GetBCDSize - GetPrecision + 1) to GetBCDSize do
  734.     decimal_str := decimal_str + char(ord('0')+Value^[i]);
  735.   if length(decimal_str) > number_of_decimal_digits then
  736.     delete(decimal_str, number_of_decimal_digits+1, 255)
  737.   else
  738.     while length(decimal_str) < number_of_decimal_digits do
  739.       decimal_str := decimal_str + '0';
  740.  
  741.   val_str := integer_str + decimal_str;
  742.  
  743.   pic_str := copy(st_Blanks, 1, length(picture));
  744.  
  745.   significant_digits_encountered := false;
  746.   sub_pic := 1;
  747.   sub_val := 1;
  748.   while sub_pic <= length(picture) do
  749.     begin
  750.       if val_str[sub_val] in ['1'..'9']then
  751.         significant_digits_encountered := true;
  752.       if upcase(picture[sub_pic]) in ['(', ')'] then
  753.         if Sign = BCDNegative then
  754.           begin
  755.             pic_str[sub_pic] := upcase(picture[sub_pic]);
  756.             sub_pic := sub_pic + 1;
  757.           end
  758.         else
  759.           begin
  760.             pic_str[sub_pic] := ' ';
  761.             sub_pic := sub_pic + 1;
  762.           end
  763.       else if upcase(picture[sub_pic]) in ['Z', '$', '-'] then
  764.         begin
  765.           if significant_digits_encountered then
  766.             pic_str[sub_pic] := val_str[sub_val]
  767.           else
  768.             pic_str[sub_pic] := ' ';
  769.           sub_pic := sub_pic + 1;
  770.           sub_val := sub_val + 1;
  771.         end
  772.       else if picture[sub_pic] = '.' then
  773.         begin
  774.           pic_str[sub_pic] := '.';
  775.           sub_pic := sub_pic + 1;
  776.           significant_digits_encountered := true;
  777.         end
  778.       else if picture[sub_pic] = '9' then
  779.         begin
  780.           pic_str[sub_pic] := val_str[sub_val];
  781.           if pic_str[sub_pic] = ' ' then pic_str[sub_pic] := '0';
  782.           sub_pic := sub_pic + 1;
  783.           sub_val := sub_val + 1;
  784.           significant_digits_encountered := true;
  785.         end
  786.       else if picture[sub_pic] = ',' then
  787.         begin
  788.           if pic_str[sub_pic - 1] = ' ' then
  789.             pic_str[sub_pic] := ' '
  790.           else
  791.             pic_str[sub_pic] := ',';
  792.           sub_pic := sub_pic + 1;
  793.         end
  794.       else
  795.         begin
  796.           pic_str[sub_pic] := upcase(picture[sub_pic]);
  797.           sub_pic := sub_pic + 1;
  798.         end;
  799.     end;
  800.  
  801.   if Sign = BCDNegative then
  802.     begin
  803.       sub_pic := 0;
  804.       while (sub_pic < length(picture)) and
  805.             (picture[sub_pic + 1] in ['(', '-', ',']) do
  806.         sub_pic := sub_pic + 1;
  807.       while (sub_pic > 0) and
  808.             (pic_str[sub_pic] <> ' ') do
  809.         sub_pic := sub_pic - 1;
  810.       if (sub_pic > 0) and
  811.          (picture[sub_pic] <> '(') then
  812.         pic_str[sub_pic] := '-';
  813.     end;
  814.  
  815.   sub_pic := 0;
  816.   while (sub_pic < length(picture)) and
  817.         (picture[sub_pic + 1] in ['(', '$', ',']) do
  818.     sub_pic := sub_pic + 1;
  819.  
  820.   while (sub_pic > 0) and
  821.         (pic_str[sub_pic] <> ' ') do
  822.     sub_pic := sub_pic - 1;
  823.  
  824.   if (sub_pic > 0) and
  825.      (picture[sub_pic] <> '(') then
  826.     pic_str[sub_pic] := '$';
  827.  
  828.   if (BlankWhenZero) and (pic_str = BCDZero^.PicStr(picture, bpw_Fixed, false)) then
  829.     pic_str := copy(st_Blanks, 1, length(picture));
  830.  
  831.   if Width = bpw_fixed then
  832.     PicStr := pic_str
  833.   else
  834.     begin
  835.       if pic_str[1] = ' ' then
  836.         begin
  837.           sub_pic := 1;
  838.           while (sub_pic < length(pic_str)) and
  839.                 (pic_str[sub_pic] = ' ') do
  840.             inc(sub_pic);
  841.           if pic_str[sub_pic] <> ' ' then dec(sub_pic);
  842.           delete(pic_str, 1, sub_pic);
  843.         end;
  844.       if pic_str[length(pic_str)] = ' ' then
  845.         begin
  846.           sub_pic := length(pic_str);
  847.           while (sub_pic > 1) and
  848.                 (pic_str[sub_pic] = ' ') do
  849.             dec(sub_pic);
  850.           if pic_str[sub_pic] <> ' ' then inc(sub_pic);
  851.           delete(pic_str, sub_pic, 255);
  852.         end;
  853.       PicStr := pic_str;
  854.     end;
  855. end;
  856.  
  857. function TBCD.StrPic(dest: PChar; picture: string;
  858.                      Width: Integer; BlankWhenZero: Boolean;
  859.                      Size: Integer): PChar;
  860. var
  861.   WrkStr:  array[0..300] of char;
  862. begin
  863.   if dest = nil then
  864.     begin
  865.       StrPic := nil;
  866.       exit;
  867.     end;
  868.  
  869.   StrPCopy(WrkStr, PicStr(picture, Width, BlankWhenZero));
  870.   StrLCopy(dest, WrkStr, Size);
  871.   StrPic := dest;
  872. end;
  873.  
  874. function TBCD.CompareBCD(AVal: PBCD): Integer;
  875. var
  876.   i:  integer;
  877.   BCD1, BCD2: PBCD;
  878. begin
  879.   if AVal = nil then exit;
  880.  
  881.   if GetSign < AVal^.GetSign then
  882.     begin
  883.       CompareBCD := -1;
  884.       exit;
  885.     end
  886.   else if GetSign > AVal^.GetSign then
  887.     begin
  888.       CompareBCD := +1;
  889.       exit;
  890.     end;
  891.  
  892.   BCD1 := new(PBCD, InitBCD(@Self));
  893.   BCD2 := new(PBCD, InitBCD(AVal));
  894.   if GetBCDSize > AVal^.GetBCDSize then
  895.     BCD2^.SetBCDSize(GetBCDSize)
  896.   else
  897.     BCD1^.SetBCDSize(AVal^.GetBCDSize);
  898.  
  899.   CompareBCD := 0;
  900.   for i := 1 to BCD1^.GetBCDSize do
  901.     begin
  902.       if BCD1^.Value^[i] < BCD2^.Value^[i] then
  903.         begin
  904.           if BCD1^.GetSign = BCDNegative then
  905.             CompareBCD := +1
  906.           else
  907.             CompareBCD := -1;
  908.           Dispose(BCD1, Done);
  909.           Dispose(BCD2, Done);
  910.           exit;
  911.         end
  912.       else if BCD1^.Value^[i] > BCD2^.Value^[i] then
  913.         begin
  914.           if BCD1^.GetSign = BCDNegative then
  915.             CompareBCD := -1
  916.           else
  917.             CompareBCD := +1;
  918.           Dispose(BCD1, Done);
  919.           Dispose(BCD2, Done);
  920.           exit;
  921.         end;
  922.     end;
  923. end;
  924.  
  925. function TBCD.CompareReal(AVal: Real): Integer;
  926. var
  927.   WrkVal: PBCD;
  928. begin
  929.   WrkVal := new(PBCD, InitReal(AVal, GetPrecision, GetBCDSize));
  930.   CompareReal := CompareBCD(WrkVal);
  931.   Dispose(WrkVal, Done);
  932. end;
  933.  
  934. function TBCD.ComparePChar(AVal: PChar): Integer;
  935. var
  936.   WrkVal: PBCD;
  937. begin
  938.   WrkVal := new(PBCD, InitPChar(AVal, GetPrecision, GetBCDSize));
  939.   ComparePChar := CompareBCD(WrkVal);
  940.   Dispose(WrkVal, Done);
  941. end;
  942.  
  943. begin
  944.   BCDZero := new(PBCD, InitReal(0.0, 2, 3));
  945.   RegisterType(RBCD);
  946. end.
  947.  
  948. { DOCUMENTATION }
  949.  
  950. AJCBCD - Binary Coded Decimal (BCD) Unit
  951.  
  952.  
  953. This unit was written using Borland International's Borland Pascal v7.0, and
  954. the Object Windows Library (OWL)/Turbo Vision (TV) library objects provided
  955. with that product.
  956.  
  957.  
  958.  
  959. I have not copyrighted this program, and donate it to the public domain.  All
  960. portions of this program may be used, modified, and/or distributed, in whole
  961. or in part.
  962.  
  963.  
  964. I wrote this unit to provide myself with some reusible functions that would
  965. provide support for BCD math similar to what I've grown accustomed to with
  966. the COBOL Packed Decimal (COMP-3) data type.  Note that in true "Packed
  967. Decimal", two decimal digits are "packed" into each data byte.  I chose not
  968. to implement my BCD support in that manner.  I may be less efficient in terms
  969. of space, but I simply placed a single decimal digit in each byte.
  970.  
  971. I am just a "hobby" programmer, having written nothing for anyone byt myself.
  972. Therefore, this unit may not be "elegant"; and, there are certainly better
  973. ways of implementing some of the routines that I coded (like perhaps coding
  974. some in assembler which I'm NOT very good at).  However, it has met my own
  975. needs, and I'm actually a little proud of what I accomplished here
  976. (especially in being able to figure out algorithms to multiply and divide!).
  977. By the way, let me admit one thing right up front...I have NOT tested ALL of
  978. the routines in this unit (in particular, the Divide routine).  I clearly
  979. marked all of the routines that have not been fully tested.  You can assume
  980. that all other routines HAVE been tested, because I used them in a real
  981. application.
  982.  
  983. This might not be the best BCD routines available, but they might actually be
  984. usefull to someone else--besides, it's free!  I am open to suggestions,
  985. comments, or enhancements (although, I can't promise quick turn around because
  986. I have a real job, plus I teach, plus I have a family--then I code for fun
  987. --in that order <grin>).  My CompuServe ID is 71331,501.
  988.  
  989. This unit exports some constants (described below).  But, the big deal in
  990. this unit is the Binary Coded Decimal object that this unit defines.  This
  991. object (TBCD) allows you to allocate a BCD data type of any number of digits.
  992. This object then provides methods for adding, subtracting, multiplying,
  993. and dividing to/from/by other numbers.  It also has methods for altering
  994. the number of digits stored as well as the precision (number of places after
  995. the decimal place).
  996.  
  997.  
  998. Constants
  999. ---------
  1000. DigitSize - Stores the size, in bytes, of each individual digit (currently
  1001.             one byte).
  1002.  
  1003. bpw_Fixed - Passed to the PicSTR and STRPic methods (see the description of
  1004.             PicSTR for an explanation of how to use this constant).
  1005.  
  1006. bpw_Variable - See bpw_Fixed above.
  1007.  
  1008. bpz_Blank - See bpw_Fixed above.
  1009.  
  1010. bpz_NotBlank - See bpw_Fixed above.
  1011.  
  1012. MaxBCDSize - Limits the maximum number of BCD digits that can be allocated
  1013.              for a BCD object.  Arbitrarily set to 100.
  1014.  
  1015. st_Blanks25 - A string constant containing 25 blanks.  Used just as a
  1016.               convenience in building the st_Blanks constant (see below).
  1017.  
  1018. st_Blanks - A String constant containing 255 blanks.  Used simply as a
  1019.             convenient reference/resource for lots of blanks (sort of like
  1020.             the "SPACES" constant in COBOL).
  1021.  
  1022. RBCD - TStreamRec used for registering the TBCD object type for use with
  1023.        streams.
  1024.  
  1025.  
  1026. Var
  1027. ---
  1028. BCDZero - A PBCD object that is initialized to a value of zero in the unit's
  1029.           initialization section.  Used as a convenience whenever you need
  1030.           a BCD object with a value of zero.
  1031.  
  1032.  
  1033. Type
  1034. ----
  1035. TBCDArray - An array of "MaxBCDSize" (100) bytes.  Allocated by the TBCD
  1036.             object to store the BCD value.  Each byte stores an individual
  1037.             digit of the value.
  1038.  
  1039. TBCDSign - An enumerated data type used by the TBCD object to represent the
  1040.            sign of the BCD value.  Valid values are "BCDNegative" and
  1041.            "BCDPositive".
  1042.  
  1043.  
  1044.  
  1045.  
  1046. TBCD
  1047. -----------------------------------------------------------------------------
  1048.  TObject       TBCD
  1049. ┌──────┐      ┌─────────────────────────────────┐
  1050. │      │      │ BCDSize                         │
  1051. ├──────┤      │ Sign                            │
  1052. │ Init │      │ Value                           │
  1053. │*Done │      │ Precision                       │
  1054. │ Free │      ├─────────────────────────────────┤
  1055. └──────┘      │ InitBCD         MultiplyByBCD   │
  1056.               │ InitReal        MultiplyByReal  │
  1057.               │ InitPChar       MultiplyByPChar │
  1058.               │ Done            DivideByBCD     │
  1059.               │ Load            DivideByReal    │
  1060.               │ Store           DivideByPChar   │
  1061.               │ GetValue        AbsoluteValue   │
  1062.               │ GetSign         Increment       │
  1063.               │ GetPrecision    Decrement       │
  1064.               │ GetBCDSize      ShiftLeft       │
  1065.               │ SetValueBCD     ShiftRight      │
  1066.               │ SetValueReal    BCD2Int         │
  1067.               │ SetValuePChar   BCD2Real        │
  1068.               │ SetSign         PicStr          │
  1069.               │ SetPrecision    StrPic          │
  1070.               │ SetBCDSize      CompareBCD      │
  1071.               │ AddBCD          CompareReal     │
  1072.               │ AddReal         ComparePChar    │
  1073.               │ AddPChar                        │
  1074.               │ SubtractBCD                     │
  1075.               │ SubtractReal                    │
  1076.               │ SubtractPChar                   │
  1077.               └─────────────────────────────────┘
  1078.  
  1079. Fields ---------------------------------------------------------------------
  1080.  
  1081. BCDSize:  Integer;                                                Read Only
  1082.  
  1083. The size, in number of digits, of the BCD number.  Count represents the
  1084. available space for digits, and does NOT include the decimal point, or sign.
  1085.  
  1086.  
  1087. Sign:  TBCDSign;                                                  Read Only
  1088.  
  1089. The mathmatical sign of the current value (i.e., indicates whether the
  1090. current value is positive or negative).
  1091.  
  1092.  
  1093. Value:  PBCDArray;                                                Read Only
  1094.  
  1095. A pointer to a TBCDArray (an array of bytes) used to store the value of the
  1096. BCD number.  Even though TBCDArray is defined with "MaxBCDSize" entries, only
  1097. BCDSize bytes are actually allocated from memory.  Therefore, you must be
  1098. sure to be careful never to read or write to subscript values greater than
  1099. BCDSize.  If you need to change the number of digits allocated you should use
  1100. the SetBCDSize method.  The BCD value is stored in the array with the lowest
  1101. order digit in the BCDSize position and the highest order digit in the 1st
  1102. position.  For example, if BCDSize is 5, Precision is 2, and the value being
  1103. stored is 2.35, then a 5-byte array would be allocated on the heap, and the
  1104. array values would be (in order from position 1 to 5) (0, 0, 2, 3, 5).
  1105.  
  1106.  
  1107. Precision:  Byte;                                                 Read Only
  1108.  
  1109. This value represents the number of digits after the decimal point.  Keep in
  1110. mind that there is no actual decimal point stored.
  1111.  
  1112.  
  1113. Methods ---------------------------------------------------------------------
  1114.  
  1115. InitBCD
  1116.  
  1117. constructor InitBCD(AVal: PBCD);
  1118.  
  1119. Sets BCDSize, Sign, and Precision to the same values as the BCD object
  1120. referred to by AVal.  It then calls SetValueBCD passing AVal in order to
  1121. allocate a TBCDArray for Value, and copies the AVal^.Value into this object's
  1122. Value array.
  1123.  
  1124.  
  1125. InitReal
  1126.  
  1127. constructor InitReal(AVal:  Real; APrec: byte; ASize: Integer);
  1128.  
  1129. Sets BCDSize to ASize, Precision to APrec, then calls SetValueReal(AVal) in
  1130. order to allocate a Value array and initialize it with the value in AVal.
  1131.  
  1132.  
  1133. InitPChar  ** Not yet tested **
  1134.  
  1135. constructor InitPChar(AVal:  PChar; APrec: byte; ASize: Integer);
  1136.  
  1137. Sets BCDSize to ASize, Precision to APrec, then calls SetValuePChar(AVal)
  1138. in order to allocate a Value array and initialize it with the value in AVal.
  1139.  
  1140.  
  1141. Done
  1142.  
  1143. destructor Done; virtual;
  1144.  
  1145. Frees the memory allocated for the Value array and calls "inherited Done".
  1146.  
  1147.  
  1148. Load
  1149.  
  1150. constructor Load(var S: TStream);
  1151.  
  1152. constructs and loads a BCD object from the stream S by first loading BCDSize,
  1153. Sign, the Value array, and last the Precision.
  1154.  
  1155.  
  1156. Store
  1157.  
  1158. procedure Store(var S: TStream);
  1159.  
  1160. Stores the BCD object on the stream S by storing the BCDSize, Sign, Value
  1161. array, and the Precision.
  1162.  
  1163.  
  1164. GetValue
  1165.  
  1166. function GetValue: PBCDArray;
  1167.  
  1168. Allocates a new TBCDArray of size BCDSize and copies the value in Value into
  1169. the new array, then returns a pointer to the new array.  Note that it will
  1170. be the calling routine's responsibility for disposing the array pointed to by
  1171. the returned pointer (use GetBCDSize to determine how much memory to free).
  1172. FreeMem should be used for this disposal, not Dispose.
  1173.  
  1174.  
  1175. GetSign
  1176.  
  1177. function GetSign: TBCDSign;
  1178.  
  1179. Returns the sign of the BCD value.  The sign is returned as a TBCDSign
  1180. value; either "BCDNegative", or "BCDPositive".
  1181.  
  1182.  
  1183. GetPrecision
  1184.  
  1185. function GetPrecision:  Byte;
  1186.  
  1187. Returns a byte value equal to the Precision (number of decimal places) of the
  1188. BCD number.
  1189.  
  1190.  
  1191. GetBCDSize
  1192.  
  1193. function GetBCDSize:  Inteteger;
  1194.  
  1195. Returns an integer value representing the number of BCD digits allocated in
  1196. the Value array.
  1197.  
  1198.  
  1199. SetValueBCD
  1200.  
  1201. procedure SetValueBCD(AVal: PBCD);
  1202.  
  1203. If Value is not nil, then the current Value array is freed.  Next, a new array
  1204. of size BCDSize is allocated on the heap, by calling AVal^.GetValue.  Next,
  1205. the copied value array is adjusted from the size and precision of AVal to
  1206. the BCDSize and Precision of this BCD object (if different).  Lastly, the
  1207. sign of the value is copied by calling AVal^.GetSign.
  1208.  
  1209.  
  1210. SetValueReal
  1211.  
  1212. procedure SetValueReal(AVal:  Real);
  1213.  
  1214. The current value array is initialized to all zero digits.  AVal is converted
  1215. to a string, and that string is copied digit by digit into the array.  If
  1216. AVal is less than zero then Sign is set to BCDNegative, otherwise it is set
  1217. to BCDPositive.
  1218.  
  1219.  
  1220. SetValuePChar  ** Not Tested Yet **
  1221.  
  1222. procedcure SetValuePChar(AVal: PChar);
  1223.  
  1224. The current value array is initialized to all zero digits.  AVal is copied
  1225. into the array digit by digit.  This routine validity checking to verify that
  1226. the string actually represents a numeric value.  The only character values
  1227. that are processed are:  1) numbers (0-9), 2) period (locates decimal point),
  1228. and 3) minus sign or parentheses to determine that the sign is negative.
  1229. Examples:  "(123.45)" would be interpreted as negative 123.45; "123.45" would
  1230. be interpreted as positive 123.45; "-123.45" would be interpreted as negative
  1231. 123.45.  Likewise, "555-55-5555" would be interpreted as a negative
  1232. 555555555; and "I'll have 2" would be interpreted as a positive 2.  If there
  1233. are no number characters in the string at all, then the resulting value is
  1234. zero.
  1235.  
  1236.  
  1237. SetSign
  1238.  
  1239. procedure SetSign(ASign: TBCDSign);
  1240.  
  1241. Sets Sign to ASign (either BCDNegative or BCDPositive).  Regardless of the
  1242. value of ASign, if the Value of the BCD is zero, then SetSign forces Sign to
  1243. be BCDPositive (in otherwords, BCD never stores a negative zero).
  1244.  
  1245.  
  1246. SetPrecision
  1247.  
  1248. procedure SetPrecision(APrec: Byte);
  1249.  
  1250. Sets Precision to APrec.  It also shifts the value array left or right,
  1251. depending on whether the precision is being increased or decreased.  If the
  1252. decimals are shifted left, dropping high order digits (hopefully zeros), and
  1253. padding zeros on the right.  If the precision is being decreased, the digits
  1254. are shifted to the right, padding the high order digits with zeros, and
  1255. dropping low order digits.  Note that the size of the value array is NOT
  1256. changed by this method.
  1257.  
  1258.  
  1259. SetBCDSize
  1260.  
  1261. procedure SetBCDSize(ASize: Integer);
  1262.  
  1263. Sets BCDSize to ASize.  It also allocates a new value array of the new size,
  1264. and copies value from the original value array to the new one.  The value
  1265. is copied right justified (in otherwords, high order digits are dropped
  1266. or padded with zeros depending on whether the new size is larger or smaller
  1267. than the old size).  The original value array is freed, and Value is set to
  1268. point to the new value array.
  1269.  
  1270.  
  1271. AddBCD
  1272.  
  1273. procedure AddBCD(AVal: PBCD);
  1274.  
  1275. Adds AVal^.Value to Self.Value.  This is a "signed add".  By that I mean that the
  1276. signs of the two operands ARE taken into account when adding the two values
  1277. together.  The result is stored in the Value array.  Mathmatically, it might
  1278. be represented by the following formula:  "Self := Self + AVal;"
  1279.  
  1280.  
  1281. AddReal
  1282.  
  1283. procedure AddReal(AVal: Real);
  1284.  
  1285. Converts AVal to a temporary PBCD object and calls AddBCD to add that
  1286. temporary BCD number to Self.
  1287.  
  1288.  
  1289. AddPChar  ** Not yet tested **
  1290.  
  1291. procedure AddPChar(AVal: PChar);
  1292.  
  1293. Converts AVal to a temporary PBCD object and calls AddBCD to add that
  1294. temporary BCD number to Self.
  1295.  
  1296.  
  1297. SubtractBCD
  1298.  
  1299. procedure SubtractBCD(AVal: PBCD);
  1300.  
  1301. Subtracts AVal^.Value from Self.Value.  This is a "signed subtract".  By that
  1302. I mean that the signs of the two operands ARE taken into account when
  1303. subtracting the two values.  The result is stored in the Value array.
  1304. Mathmatically, it might be represented by the following formula:
  1305. "Self := Self - AVal;"
  1306.  
  1307.  
  1308. SubtractReal  ** Not yet tested **
  1309.  
  1310. procedure SubtractReal(AVal: Real);
  1311.  
  1312. Converts AVal to a temporary PBCD object and calls SubtractBCD to subtract
  1313. that temporary BCD number from Self.
  1314.  
  1315.  
  1316. SubtractPChar  ** Not yet tested **
  1317.  
  1318. procedure SubtractPChar(AVal: PChar);
  1319.  
  1320. Converts AVal to a temporary PBCD object and calls SubtractBCD to subtract
  1321. that temporary BCD number from Self.
  1322.  
  1323.  
  1324. MultiplyByBCD
  1325.  
  1326. procedure MultiplyByBCD(AVal: PBCD);
  1327.  
  1328. Multiplies Self.Value by AVal^.Value.  This is a "signed multiply".  By that
  1329. I mean that the signs of the two operands ARE taken into account when
  1330. multiplying the two values.  The result is stored in the Value array.
  1331. Mathmatically, it might be represented by the following formula:
  1332. "Self := Self * AVal;"
  1333.  
  1334.  
  1335. MultiplyByReal  ** Not yet tested **
  1336.  
  1337. procedure MultiplyByReal(AVal: Real);
  1338.  
  1339. Converts AVal to a temporary PBCD object and calls MultiplyByBCD to
  1340. multiply Self by that temporary BCD number.
  1341.  
  1342.  
  1343. MultiplyByPChar  ** Not yet tested **
  1344.  
  1345. procedure MultiplyByPChar(AVal: PChar);
  1346.  
  1347. Converts AVal to a temporary PBCD object and calls MultiplyByBCD to
  1348. mulitiply Self by that temporary BCD number.
  1349.  
  1350.  
  1351. DivideByBCD  ** Not yet tested **
  1352.  
  1353. procedure DivideByBCD(AVal: PBCD);
  1354.  
  1355. Divides Self.Value by  AVal^.Value.  This is a "signed divide".  By that
  1356. I mean that the signs of the two operands ARE taken into account when
  1357. dividing the two values.  The result is stored in the Value array.
  1358. Mathmatically, it might be represented by the following formula:
  1359. "Self := Self/AVal;"
  1360.  
  1361.  
  1362. DivideByReal  ** Not yet tested **
  1363.  
  1364. procedure DivideByReal(AVal:  Real);
  1365.  
  1366. Converts AVal to a temporary PBCD object and calls DivideByBCD to divide
  1367. Self by that temporary BCD number.
  1368.  
  1369.  
  1370. DivideByPChar  ** Not yet tested **
  1371.  
  1372. procedure DivideByPChar(AVal:  Real);
  1373.  
  1374. Converts AVal to a temporary PBCD object and calls DivideByBCD to divide
  1375. Self by that temporary BCD number.
  1376.  
  1377.  
  1378. AbsoluteValue
  1379.  
  1380. procedure AbsoluteValue;
  1381.  
  1382. Calls SetSign to set Sign to BCDPositive, regardless of its current value.
  1383.  
  1384.  
  1385. Increment  ** Not yet tested **
  1386.  
  1387. procedure Increment;
  1388.  
  1389. Adds 1 Value.
  1390.  
  1391.  
  1392. Decrement  ** Not yet tested **
  1393.  
  1394. procedure Decrement;
  1395.  
  1396. Subtracts 1 from Value.
  1397.  
  1398.  
  1399. ShiftLeft
  1400.  
  1401. procedure ShiftLeft(ShiftAmount: Byte);
  1402.  
  1403. Shifts all of the digits left by ShiftAmount, dropping high order digits, and
  1404. padding the low order digits with zeros.  The Precision of the number is NOT
  1405. altered.  In effect, ShiftLeft multiplies Value by a power of 10.
  1406.  
  1407.  
  1408. ShiftRight
  1409.  
  1410. procedure ShiftRight(ShiftAmount: Byte);
  1411.  
  1412. Shifts all of the digits right by ShiftAmount, dropping low order digits, and
  1413. padding the high order digits with zeros.  The Precision of the number is NOT
  1414. altered.  In effect, ShiftRight divides Value by a power of 10.
  1415.  
  1416.  
  1417. BCD2Int  ** Not yet tested **
  1418.  
  1419. function BCD2Int: LongInt;
  1420.  
  1421. Converts the BCD value (and it's sign) to a LongInt data value.  Decimal
  1422. positions are simply truncated, not rounded.  Range checking is not performed.
  1423. If the number of significant digits of the BCD number (not counting decimal
  1424. positions) is too large for a LongInt number, high order digits are lost,
  1425. and the resulting LongInt value will probably be meaningless.
  1426.  
  1427.  
  1428. BCD2Real  ** Not yet tested **
  1429.  
  1430. function BCD2Real:  Real;
  1431.  
  1432. Converts the BCD value (and it's sign) to a Real data value.  Range checking
  1433. is not performed.  If the number of significant digits of the BCD number is
  1434. too loarge for a Real number, the results are unpredictable, and will
  1435. probably be meaningless.
  1436.  
  1437.  
  1438. PicStr
  1439.  
  1440. function PicStr(picture: string;
  1441.                 Width: Integer; BlankWhenZero: Boolean): string;
  1442.  
  1443. PicStr converts the BCD number into a formatted Pascal string.  If you are
  1444. familiar with the used of Edit Numeric Formatting in Cobol, then you're a
  1445. long ways toward understanding how to use this routine.
  1446.  
  1447. First, let's get the simple parameters out of the way...
  1448.  
  1449. Width indicates whether or not insignificant leading and trailing blanks
  1450. should be removed from the resulting string.  If Width is equal to 0 then the
  1451. length of the resulting string will always equal the length of Picture,
  1452. regardless of any leading or trailing blanks in the result string.  If Width
  1453. is equal to 1, then any leading and/or trailing blanks will be removed from
  1454. the resulting string before returning.  For your convenience, two constants
  1455. have been defined for use with this parameter:  bpw_Fixed = 0 and
  1456. bpw_Variable = 1.
  1457.  
  1458. BlankWhenZero indicates whether the entire result string should be forced to
  1459. completely blank, regardless of any formatting characters in Picture, if the
  1460. formatted value is logically equal to zero.  The BCD value itself is NOT used
  1461. to make this determination.  The determination is made by comparing the
  1462. result string to the string from formatting BCDZero (zero value) with the
  1463. same Picture string.  If the two strings are equal, then this result string
  1464. is considered to be equal to zero.  If BlankWhenZero is true, then such zero
  1465. valued results are forced to all blanks.  If BlankWhenZero is false, the
  1466. the result string is left to whatever it becomes based on the Picture string.
  1467. If BlankWhenZero is true, and Width = bpw_Fixed, then the result string is
  1468. a string of blanks equal in length to the length of Picture.  If Width =
  1469. bpw_Variable, the the result will be an empty strint ('').  For example, if
  1470. the BCD number = 0.0023, and the formatted result is "0.00%", BlankWhenZero =
  1471. false would result in "0.00%", while BlankWhenZero = true would result in a
  1472. blank or empty string depending on Width.  For your convenience, two constants
  1473. have been defined for use with this parameter:  bpz_Blank = true, and
  1474. bpz_NotBlank = false.
  1475.  
  1476. Now, the more complicated part...picture...
  1477.  
  1478. The "picture" parameter is a string that provides a template for formatting
  1479. the value of the BCDnumber.  The possible template characters are...
  1480.   '9' - Fills with a digit from the value (or zero if no digit position
  1481.         available in the BCD number)
  1482.   'Z' - Just like '9', except that insignificant zeros (i.e., leading zeros)
  1483.         are left blank.
  1484.   'z' - Exactly the same as a capital "Z"
  1485.   '$' - Just like 'Z', except that the right most unused (blank)
  1486.         dollar-sign position is filled with a '$'.  COBOL afficianados will
  1487.         recognize this as a "floating dollar sign".
  1488.   '-' - Just like 'Z', except that if the BCD number value is negative, then
  1489.         the right most unused (blank) dash position is filled with a '-'.
  1490.         COBOL afficianoados will recognize this as a "floating negative sign".
  1491.   '(' - If the template contains a parenthesis, and the BCD number value is
  1492.         negative, then the result string is surrounded with parenthesis.
  1493.   ')' - If the template contains a parenthesis, and the BCD number value is
  1494.         negative, then the result string is surrounded with parenthesis.
  1495.   '.' - Indicates the decimal point position, and is included in the result
  1496.         string.  If the template does not contain a period, then the decimal
  1497.         position is assumed to be at the right end of the template, no
  1498.         decimal point is included in the result string, and no decimal place
  1499.         values are included in the result string.
  1500.   ',' - If any significant (non-zero) value positions precede the comma
  1501.         position, then a comma is inserted at this position in the result
  1502.         string.  This would normally be used to format commas to separate
  1503.         thousands positions in large numbers.
  1504.   ANY other characters are simply inserted into the result string in their
  1505.   relative position.
  1506.  
  1507. Some examples might help...
  1508.  
  1509.     Value         Picture String         Fixed Result       Variable Result
  1510.     123.45          '$$$$$9.99'           '  $123.45'        '$123.45'
  1511.     123456.78       '$$$$$9.99'           '123456.78'        '123456.78'
  1512.     123456.78       '$$$$$$9.99'          '$123456.78'       '$123456.78'
  1513.     123456.78       '$,$$$,$$9.99'        '$123,456.78'      '$123,456.78'
  1514.     123.45          '9999'                '0123'             '0123'
  1515.     -1234.6         '---,--9.99'          ' -1,234.60'       '-1,234.60'
  1516.     -10.15          '(99.99)'             '(10.15)'          '(10.15)'
  1517.     10.15           '(99.99)'             ' 10.15 '          '10.15'
  1518.     75              'z9.999%'             '75.000%'          '75.000%'
  1519.  
  1520. Got the idea?  I hope so.  I have developed a similar stand-alone routine
  1521. for formatting inteter and real numbers, and find it to be a VERY handy way
  1522. to nicely format my number values for presentation on the screen or on a
  1523. paper report.
  1524.  
  1525.  
  1526. StrPic  ** Not yet tested **
  1527.  
  1528. function StrPic(dest: PChar; picture: string;
  1529.                 Width: Integer; BlankWhenZero: Boolean): PChar;
  1530.  
  1531. Calls PicStr(picture, Width, BlankWhenZero) to get a formatted Pascal string.
  1532. This string is converted to an null terminated string.  StrLCopy is used to
  1533. copy that null terminated string to Dest, limited by Size.  See PicStr for an
  1534. explanation of the use of picture, Width, and BlankWhenZero.  StrPic returns
  1535. a pointer to dest.
  1536.  
  1537.  
  1538. CompareBCD
  1539.  
  1540. function CompareBCD(AVal: PBCD): Integer;
  1541.  
  1542. Compares the signed values of Self and AVal.  CompareBCD returns -1 if Self
  1543. is less than AVal, returns +1 of Self is greater than AVal, and returns 0 if
  1544. the two values are equal.
  1545.  
  1546.  
  1547. CompareReal  ** Not yet tested **
  1548.  
  1549. function CompareReal(AVal: Real): Integer;
  1550.  
  1551. Converts AVal to a temporary PBCD object and calls CompareBCD to perform the
  1552. actual comparison with that temporary BCD number.  CompareReal returns the
  1553. value returned by CompareBCD.
  1554.  
  1555. ComparePChar  ** Not yet tested **
  1556.  
  1557.  
  1558. function ComparePChar(AVal: PChar): Integer;
  1559.  
  1560. Converts AVal to a temporary PBCD object and calls CompareBCD to perform the
  1561. actual comparison with that temporary BCD number.  ComparePChar returns the
  1562. value returned by CompareBCD.